MacWorld 1999 July

home *** CD-ROM | disk | FTP | other *** search

/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / Module source / zCasemod.txt / zCasemod.txt

Wrap

Text File | 1999-02-03 | 12.1 KB | 475 lines | [TEXT/MSET]

\ This module handles the implementation of our case constructs \ CASE[ and SELECT[. \ Notice that we don't use any assembler at all, and only need one \ special handler word CaseJMP to compile an indexed dispatch for SELECT[. \ We compile sequences that the optimizer will pick up so that the resulting \ code is pretty well optimum anyway. The key to this is the use of the \ pseudo-value "Treg" which is actually the machine register D1. false constant case_dbg? \ : do_case_dbg true -> case_dbg? ; enum{ keyed_case indexed_case } 240 constant KEYED_CHK 250 constant INDEXED_CHK (* : compBR 1 operands adjust_stks opnd1 ( invert?) true setup_conditional_branch free: opnd1 reg: opnd1 NIF false -> using_CR0 THEN compile: branch_instrn ; *) : compUBR compile_unconditional_branch ; : CASE[ \ ( -- saved-cstk CDP Schain Fchain endChain end_stub_cnt end-stub? chk ) \ Implements CASE[ . case_type \ save over nested cases keyed_case -> case_type 2 -1 simple_equalize \ we have to do this here in all cases, since [ below would \ do it anyway, but we need to have the right cstk saved \ first. Actually we could probably do without saving and \ restoring cstk, but it's best to keep the code as much \ like the 68k version as possible. save: cstk save: fcstk \ save cstk/fcstk state - this will apply at the start of \ each stub CDP -> backstop_CDP CDP \ CDP for the start of the first stub \ eval" -> treg" 0 \ initial success chain 0 \ initial fail chain 0 \ initial end chain -1 \ end_stub_cnt = undefined - no stubs yet false \ no end of stub yet keyed_chk \ check value postpone [ ; immediate : ADD_ENTRY ( saved-cstk ) { chk link \ mark-addr -- link' } restore: fcstk2 restore: cstk2 \ get rid of saved cstk/fcstk which we never need pop: control_stk -> mark-addr \ mark addr is addr of branch instrn link IF link mark-addr 2+ wdispl! \ store prev mark (if any) in lo 2 bytes of br THEN mark-addr \ mark addr is new link ; : RESOLVE { link \ nxt -- } BEGIN link WHILE \ need these next two lines while we're debugging - and aren't we always... link 2+ w@x -800 0 within? NIF db cr ." garbage link in resolve" 1 die THEN drop link 2+ wdisplace -> nxt link push: control_stk 0 push: control_flags 120 >resolve nxt -> link REPEAT ; \ FIX_STUB is called at the end of a stub. We do many strange and \ intricate things... : FIX_STUB { stub_start_CDP Schain Fchain endChain end_stub_cnt -- endChain' end_stub_cnt' } case_dbg? if db cdp drop then end_stub_cnt 0< IF size: cstk -> end_stub_cnt THEN stub_start_CDP 4- -> startCDP make_altered_regs_unknown end_stub_cnt -1 simple_equalize compUBR >mark \ compile branch to end endChain add_entry \ leaves updated endChain Fchain resolve \ resolves fail chain to here end_stub_cnt ; : NEW_STUB ( <saved-cstk> ) { stub_start_CDP Schain Fchain endChain end_stub_cnt end-stub? chk lo hi flg -- <saved-cstk> stub_start_CDP' Schain' Fchain' endChain' end-stub? chk } case_dbg? if db -999 cdp 2drop then postpone ] \ Must be compiling for evaluates below keyed_chk chk ?pairs end-stub? IF stub_start_CDP Schain Fchain endChain end_stub_cnt fix_stub -> end_stub_cnt -> endChain 0 -> Schain 0 -> Fchain THEN restore: fcstk restore: cstk save: cstk save: fcstk \ get cstk/fcstk to what they were at the start update_refcnts \ of the construct, which of course is \ what it's got to be at the start of each \ stub, just before the test. hi lo <> IF lo postpone literal " over > nif" evaluate Fchain add_entry -> Fchain hi postpone literal " over <" evaluate flg IF postpone nif Fchain add_entry -> Fchain ELSE postpone if Schain add_entry -> Schain THEN ELSE hi postpone literal " over =" evaluate flg IF \ starting a stub postpone if Fchain add_entry -> Fchain ELSE \ ], or whatever - not up to the stub yet postpone nif Schain add_entry -> Schain THEN THEN flg IF \ we're starting the stub code right here case_dbg? if db 999 cdp 2drop then CDP -> backstop_CDP \ dispatch code gets mangled if we don't \ do this! Schain resolve postpone drop \ get rid of the test value Schain IF CDP 4- -> Fchain THEN \ we clear Schain next time around, \ since at FIX_STUB we need to know \ whether anything was on it ELSE hi lo <> IF Fchain resolve 0 -> Fchain THEN THEN CDP Schain Fchain endChain end_stub_cnt flg \ flg is end_stub? for next time keyed_chk \ check value ; : DEFAULT ( <saved-cstk> ) { stub_start_CDP Schain Fchain endChain end_stub_cnt end-stub? chk -- CDP end_stub_cnt endChain chk } case_dbg? if db $ 100 cdp 2drop then keyed_chk chk ?pairs end-stub? IF stub_start_CDP Schain Fchain endChain end_stub_cnt fix_stub -> end_stub_cnt -> endChain THEN restore: fcstk restore: cstk \ get cstk/fcstk to what they were at the start of update_refcnts \ the construct, as we do for all the stubs CDP -> backstop_CDP \ postpone treg \ diff postpone literal postpone + CDP end_stub_cnt endChain keyed_chk 1+ ; : ]CASE { dflt_CDP end_stub_cnt endChain chk -- } keyed_chk 1+ chk ?pairs dflt_CDP 4- -> startCDP make_altered_regs_unknown end_stub_cnt -1 simple_equalize \ wind up default stub properly \ now we'll resolve the endChain - note that the cstk state is already \ equalized to end_stub_cnt, which is precisely correct for here, so \ we can leave it alone. endChain resolve -> case_type ; immediate \ Now for an indexed case, with similar style syntax: 0 value MAXINDEX 0 value MININDEX 0 value ADDRX \ just for testing : SELECT[ \ ( -- lots ) case_type maxindex minindex \ Save on stack for nested cases indexed_case -> case_type 2 -1 simple_equalize \ we have to do this here in all cases, since [ below would \ do it anyway, but we need to have the right cstk saved \ by >mark below. Actually we could probably do without saving \ and restoring cstk, but it's best to keep the code as much \ like the 68k version as possible. \ 1 stk: cstk gpr: cstk select: GPRs CDP put: ivar> lastrefcdp in GPRs \ printall: cstk print: GPRs 0 -> maxindex big# -> minindex $ dddddddd 1 \ Dummy 2-cell entry, so ]SELECT knows when to stop compUBR >mark \ Forward branch to dispatch code - also saves cstk state, \ which will apply at the start of each stub drop \ drop >mark check value CDP -> backstop_CDP CDP \ CDP for the start of the first stub 0 \ initial end chain -1 \ end_stub_cnt = undefined - no stubs yet false \ no end of stub yet indexed_chk \ check value postpone [ ; immediate : TBL_FIX_STUB { stub_start_CDP endChain end_stub_cnt -- endChain' end_stub_cnt' } end_stub_cnt 0< IF size: cstk -> end_stub_cnt THEN \ stub_start_CDP 4- -> startCDP make_altered_regs_unknown 0 -> startCDP make_altered_regs_unknown end_stub_cnt -1 simple_equalize compUBR >mark endChain add_entry \ leaves new endChain end_stub_cnt ; : TBL_NEW_STUB ( <saved-cstk> ) { stub_start_CDP endChain end_stub_cnt end-stub? chk index flg -- index CDP <saved-cstk> CDP endChain' end_stub_cnt' end-stub? chk } postpone ] chk indexed_chk ?pairs index 0< ?error 68 case_dbg? if db $ 102 cdp 2drop then index maxindex max -> maxindex index minindex min -> minindex maxindex 400 > if msg# 69 then end-stub? IF stub_start_CDP endChain end_stub_cnt tbl_fix_stub -> end_stub_cnt -> endChain THEN CDP -> backstop_CDP \ dispatch code gets mangled if we don't \ do this! restore: fcstk restore: cstk \ get cstk/fcstk to what they were at the update_refcnts \ start of the construct, which of course is \ what it's got to be at the start of each \ stub. index CDP \ leave these on the stack for the end save: cstk save: fcstk \ save cstk/fcstk again for next stub postpone drop \ non-default stubs have index value dropped CDP endChain end_stub_cnt flg \ flg is end_stub? for next time indexed_chk \ check value ; : TBL_DEFAULT ( <saved-cstk> ) { stub_start_CDP endChain end_stub_cnt end-stub? chk -- <saved-cstk> CDP endChain end_stub_cnt chk } end-stub? IF stub_start_CDP endChain end_stub_cnt tbl_fix_stub -> end_stub_cnt -> endChain THEN restore: fcstk restore: cstk \ get cstk/fcstk to what they were at the start of update_refcnts \ the construct, as we do for all the stubs CDP -> backstop_CDP save: cstk save: fcstk \ save again for dispatch code CDP \ here's where the default code will start endChain end_stub_cnt indexed_chk 1+ ; : ]SELECT ( $dddddddd 1 index CDP1 index CDP2 ... <saved-cstk> ) { dflt_CDP endChain end_stub_cnt chk \ tbl_start svCDP -- } indexed_chk 1+ chk ?pairs dflt_CDP endChain end_stub_cnt tbl_fix_stub \ wind up default stub properly -> end_stub_cnt -> endChain save: cstk save: fcstk restore: fcstk_temp restore: cstk_temp \ save cstk state for stub ends restore: fcstk restore: cstk \ get cstk/fcstk to what they were at the start update_refcnts \ of the construct, which is what applies at the \ start of the dispatch code: \ Now we build the table: CDP -> tbl_start maxindex minindex - 1+ 2* code_allot dflt_CDP tbl_start - ( now relative to tbl_addr ) CDP 2- \ last entry addr tbl_start DO ( fill table with dflt addr initially ) dup i w! 2 +LOOP drop BEGIN ( index addr ) dup 1 = NWHILE ( index addr ) tbl_start - swap minindex - 2* tbl_start + w! REPEAT 2drop \ Now we generate the dispatch code: code_align 120 \ check value for >resolve >resolve " dup 2* -> rX" evaluate minindex 2* postpone literal " --> rX" evaluate \ Compiles nothing if minindex is zero maxindex minindex - 2* postpone literal " rX u< nif" evaluate drop restore: fcstk2 restore: cstk2 \ drop cstk state - dflt stub already fixed CDP -> svCDP dflt_CDP -> CDP 120 >resolve \ branch is actually back, but that's OK svCDP -> CDP tbl_start code_addr_in_curr_def " -> rY rX rY + w@x -> treg rY +> treg" evaluate \ treg is r0 $ 7C0903A6 code, \ mtctr r0 $ 4E800420 code, \ bctr \ now we'll resolve the endChain - note that the cstk state also needs to be \ set to what it is at the end of all the stubs - no equalization is needed, \ since we're just setting it to what it really is already. We saved this \ state earlier, in cstk_temp. save: cstk_temp save: fcstk_temp restore: fcstk restore: cstk update_refcnts endChain resolve -> minindex -> maxindex -> case_type ; immediate \ These words are the same in both constructs, so we work out which action \ to apply by looking at case_type. : ]=> case_type keyed_case = IF dup true new_stub ELSE true tbl_new_stub THEN ; immediate : ], case_type keyed_case = IF dup false new_stub ELSE false tbl_new_stub THEN ; immediate : RANGE]=> true new_stub ; immediate : RANGE], false new_stub ; immediate : DEFAULT=> \ case_dbg? if db $ 101 cdp 2drop then case_type keyed_case = IF default ELSE tbl_default THEN ; immediate endload +echo \ Torture tests - something as complicated as that needs \ a bit of systematic testing... : q db select[ 3 ]=> 23 [ 2 ]=> 22 [ 0 ]=> 20 [ 8 ]=> 28 default=> 999 ]select ; : qq case[ 21 ]=> 210 [ 22 ]=> 220 [ 80 ], [ 82 ], [ 84 ], [ 86 ]=> 888 [ 30 40 range]=> 333 [ 90 ], [ 92 ], [ 170 ]=> -999 [ 90 ], [ 92 ], [ 100 150 range], [ 170 ]=> -999 [ 222 ]=> 2220 default=> 99 ]case ; : ?CHK 2dup <> IF cr .h cr .h true abort" check FAILED!!!" \ error if something doesn't \ give what we expect ELSE 2drop THEN ; +echo 21 qq 210 ?chk 22 qq 220 ?chk 80 qq 888 ?chk 84 qq 888 ?chk 85 qq 99 ?chk 85 ?chk 35 qq 333 ?chk 92 qq -999 ?chk 120 qq -999 ?chk 170 qq -999 ?chk 222 qq 2220 ?chk 9999 qq 99 ?chk 9999 ?chk 3 q 23 ?chk 2 q 22 ?chk 8 q 28 ?chk 6 q 999 ?chk 6 ?chk -1 q 999 ?chk -1 ?chk 9 q 999 ?chk 9 ?chk \ torture tests WORKED!